C $TITLE: 'NETWK'
C $NOFLOATCALLS
C
C
C
      SUBROUTINE NETWK(CM,CMB,CMC,CMD,EINC,RHS,SCRATC,
     1 AIR,AII,BIR,BII,CIR,CII,T1X,T1Y,T1Z,T2X,T2Y,T2Z,BI,
     2 ICON1,ICON2,ITAG,IP,IW,LD,LD2,LD3,IRESRV)
C
C     SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVEN
C     EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IF
C     PRESENT.
C
      REAL*8 TP,AIR,AII,BIR,BII,CIR,CII,ASA,ASM,PWR
CLARGE: CM,CMB,CMC,CMD,CMN,EINC,RHS,RHNT
      COMPLEX CM,CMB,CMC,CMD,CMN,EINC,RHS,RHNT
      COMPLEX*16 SCRATC
      COMPLEX*16 VQD,VSANT,VQDS
      COMPLEX*16 VSRC,RHNX,ZPED
      COMPLEX*16 YMIT,VLT,CUX
      INTEGER*4 NEQ,NPEQ,NEQ2,NTEQ,NDIMN,NEQT
      INTEGER*4 ICON1,ICON2,ITAG,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
      COMMON/VSORC/VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
     1 IQDS(30),NVQD,NSANT,NQDS
      COMMON/NETCX/ZPED,PIN,PNLS,NEQ,NPEQ,NEQ2,NONET,NTSOL,NPRINT,
     1 MASYM,ISEG1(30),ISEG2(30),X11R(30),X11I(30),X12R(30),X12I(30),
     2 X22R(30),X22I(30),NTYP(30)
      COMMON/NETWKC/CMN(30,30),RHNT(30),IPNT(30),NTEQA(30),NTSCA(30),
     1 VSRC(30),RHNX(30),NAMPRT
      DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),BI(LD)
      DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
      DIMENSION CM(IRESRV),EINC(LD3),CMB(1),CMC(1),CMD(1),SCRATC(LD2),
     1 RHS(LD3),IP(LD2),ICON1(LD),ICON2(LD),ITAG(LD)
C**
C $NODEBUG
C**
C      DATA NDIMN,NDIMNP/30,31/,TP/6.283185308D0/
      DATA NDIMN,NDIMNP/100,101/,TP/6.283185308D0/
C**
C     D      WRITE(*,*) '  NETWK: START'
C**
$DEBUG
C**
      NEQZ2=NEQ2
      IF(NEQZ2.EQ.0)NEQZ2=1
      PIN=0.
      PNLS=0.
      NEQT=NEQ+NEQ2
      IF (NTSOL.NE.0) GO TO 42
      NOP=NEQ/NPEQ
C**
      IF((MASYM.EQ.0).OR.(NAMPRT.NE.0)) GO TO 14
C
C     COMPUTE RELATIVE MATRIX ASYMMETRY
C
C**
C     D      WRITE(*,*) '  NETWK: COMPUTE RELATIVE MATRIX ASYMMETRY'
C**
      IROW1=0
      IF (NONET.EQ.0) GO TO 5
      DO 4 I=1,NONET
      NSEG1=ISEG1(I)
      DO 3 ISC1=1,2
      IF (IROW1.EQ.0) GO TO 2
      DO 1 J=1,IROW1
      IF (NSEG1.EQ.IPNT(J)) GO TO 3
1     CONTINUE
2     IROW1=IROW1+1
      IPNT(IROW1)=NSEG1
3     NSEG1=ISEG2(I)
4     CONTINUE
5     IF (NSANT.EQ.0) GO TO 9
      DO 8 I=1,NSANT
      NSEG1=ISANT(I)
      IF (IROW1.EQ.0) GO TO 7
      DO 6 J=1,IROW1
      IF (NSEG1.EQ.IPNT(J)) GO TO 8
6     CONTINUE
7     IROW1=IROW1+1
      IPNT(IROW1)=NSEG1
8     CONTINUE
9     IF (IROW1.LT.NDIMNP) GO TO 10
      WRITE(IW,59)
      STOP
10    IF (IROW1.LT.2) GO TO 14
      DO 12 I=1,IROW1
      ISC1=IPNT(I)
      ASM=T1X(ISC1)
      DO 11 J=1,NEQT
11    RHS(J)= CMPLX(0.,0.)
      RHS(ISC1)= CMPLX(1.,0.)
C**
C     D      WRITE(*,*) '  NETWK: CALL SOLGF AFTER 11'
C**
      CALL SOLGF(CM,CMB,CMC,CMD,RHS,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
     1 NEQZ2,IP,LD2,LD3,IRESRV)
C**
C     D      WRITE(*,*) '  NETWK: RTRN SOLGF AFTER 11'
C     D      WRITE(*,*) '  NETWK: CALL CABC AFTER 11'
C**
      CALL CABC(RHS,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
     1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
C**
C     D      WRITE(*,*) '  NETWK: RTRN CABC AFTER 11'
C**
      DO 12 J=1,IROW1
      ISC1=IPNT(J)
12    CMN(J,I)=RHS(ISC1)/ASM
      ASM=0.
      ASA=0.
      DO 13 I=2,IROW1
      ISC1=I-1
      DO 13 J=1,ISC1
      CUX=CMN(I,J)
C      PWR=CABS((CUX-CMN(J,I))/CUX)
      PWR=ZABS((CUX-CMN(J,I))/CUX)
      ASA=ASA+PWR*PWR
      IF (PWR.LT.ASM) GO TO 13
      ASM=PWR
      NTEQ=IPNT(I)
      NTSC=IPNT(J)
13    CONTINUE
C**
      ASA=DSQRT(ASA*2./FLOAT(IROW1*(IROW1-1)))
      WRITE(IW,58)  ASM,NTEQ,NTSC,ASA
14    IF (NONET.EQ.0) GO TO 48
C
C     SOLUTION OF NETWORK EQUATIONS
C
      DO 15 I=1,NDIMN
      RHNX(I)=DCMPLX(0.,0.)
      DO 15 J=1,NDIMN
15    CMN(I,J)= CMPLX(0.,0.)
      NTEQ=0
      NTSC=0
C
C     SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TO
C     SEGMENTS.
C
      DO 38 J=1,NONET
      NSEG1=ISEG1(J)
      NSEG2=ISEG2(J)
      IF (NTYP(J).GT.1) GO TO 16
      Y11R=X11R(J)
      Y11I=X11I(J)
      Y12R=X12R(J)
      Y12I=X12I(J)
      Y22R=X22R(J)
      Y22I=X22I(J)
      GO TO 17
16    Y22R=TP*X11I(J)/WLAM
      Y12R=0.
      Y12I=1./(X11R(J)*SIN(Y22R))
      Y11R=X12R(J)
      Y11I=-Y12I*COS(Y22R)
      Y22R=X22R(J)
      Y22I=Y11I+X22I(J)
      Y11I=Y11I+X12I(J)
      IF (NTYP(J).EQ.2) GO TO 17
      Y12R=-Y12R
      Y12I=-Y12I
17    IF (NSANT.EQ.0) GO TO 19
      DO 18 I=1,NSANT
      IF (NSEG1.NE.ISANT(I)) GO TO 18
      ISC1=I
      GO TO 22
18    CONTINUE
19    ISC1=0
      IF (NTEQ.EQ.0) GO TO 21
      DO 20 I=1,NTEQ
      IF (NSEG1.NE.NTEQA(I)) GO TO 20
      IROW1=I
      GO TO 25
20    CONTINUE
21    NTEQ=NTEQ+1
      IROW1=NTEQ
      NTEQA(NTEQ)=NSEG1
      GO TO 25
22    IF (NTSC.EQ.0) GO TO 24
      DO 23 I=1,NTSC
      IF (NSEG1.NE.NTSCA(I)) GO TO 23
      IROW1=NDIMNP-I
      GO TO 25
23    CONTINUE
24    NTSC=NTSC+1
      IROW1=NDIMNP-NTSC
      NTSCA(NTSC)=NSEG1
      VSRC(NTSC)=VSANT(ISC1)
25    IF (NSANT.EQ.0) GO TO 27
      DO 26 I=1,NSANT
      IF (NSEG2.NE.ISANT(I)) GO TO 26
      ISC2=I
      GO TO 30
26    CONTINUE
27    ISC2=0
      IF (NTEQ.EQ.0) GO TO 29
      DO 28 I=1,NTEQ
      IF (NSEG2.NE.NTEQA(I)) GO TO 28
      IROW2=I
      GO TO 33
28    CONTINUE
29    NTEQ=NTEQ+1
      IROW2=NTEQ
      NTEQA(NTEQ)=NSEG2
      GO TO 33
30    IF (NTSC.EQ.0) GO TO 32
      DO 31 I=1,NTSC
      IF (NSEG2.NE.NTSCA(I)) GO TO 31
      IROW2=NDIMNP-I
      GO TO 33
31    CONTINUE
32    NTSC=NTSC+1
      IROW2=NDIMNP-NTSC
      NTSCA(NTSC)=NSEG2
      VSRC(NTSC)=VSANT(ISC2)
33    IF (NTSC+NTEQ.LT.NDIMNP) GO TO 34
      WRITE(IW,59)
      STOP
C
C     FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH
C     NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS.
C
34    IF (ISC1.NE.0) GO TO 35
      CMN(IROW1,IROW1)=CMN(IROW1,IROW1)-CMPLX(Y11R,Y11I)*T1X(NSEG1)
      CMN(IROW1,IROW2)=CMN(IROW1,IROW2)-CMPLX(Y12R,Y12I)*T1X(NSEG1)
      GO TO 36
35    RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y11R,Y11I)*VSANT(ISC1)/WLAM
      RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y12R,Y12I)*VSANT(ISC1)/WLAM
36    IF (ISC2.NE.0) GO TO 37
      CMN(IROW2,IROW2)=CMN(IROW2,IROW2)-CMPLX(Y22R,Y22I)*T1X(NSEG2)
      CMN(IROW2,IROW1)=CMN(IROW2,IROW1)-CMPLX(Y12R,Y12I)*T1X(NSEG2)
      GO TO 38
37    RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y12R,Y12I)*VSANT(ISC2)/WLAM
      RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y22R,Y22I)*VSANT(ISC2)/WLAM
38    CONTINUE
C
C     ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATION
C     MATRIX
C
      DO 41 I=1,NTEQ
      DO 39 J=1,NEQT
39    RHS(J)=(0.,0.)
      IROW1=NTEQA(I)
      RHS(IROW1)= CMPLX(1.,0.)
C**
C     D      WRITE(*,*) '  NETWK: CALL SOLGF AFTER 39'
C**
      CALL SOLGF(CM,CMB,CMC,CMD,RHS,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
     1 NEQZ2,IP,LD2,LD3,IRESRV)
C**
C     D      WRITE(*,*) '  NETWK: RTRN SOLGF AFTER 39'
C     D      WRITE(*,*) '  NETWK: CALL CABC AFTER 39'
C**
      CALL CABC(RHS,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
     1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
C**
C     D      WRITE(*,*) '  NETWK: RTRN CABC AFTER 39'
C**
      DO 40 J=1,NTEQ
      IROW1=NTEQA(J)
40    CMN(I,J)=CMN(I,J)+RHS(IROW1)
41    CONTINUE
C
C     FACTOR NETWORK EQUATION MATRIX
C
      CALL FACTR(CMN,SCRATC,NTEQ,NDIMN,IPNT,LD2)
C
C     ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENT
C     INTERACTIONS
C
42    IF (NONET.EQ.0) GO TO 48
      DO 43 I=1,NEQT
      RHS(I)=EINC(I)
43      CONTINUE
C**
C     D      WRITE(*,*) '  NETWK: CALL SOLGF, CABC AFTER 43'
C**
      CALL SOLGF(CM,CMB,CMC,CMD,RHS,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
     1 NEQZ2,IP,LD2,LD3,IRESRV)
      CALL CABC(RHS,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
     1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
      DO 44 I=1,NTEQ
      IROW1=NTEQA(I)
44    RHNT(I)=RHNX(I)+RHS(IROW1)
C
C     SOLVE NETWORK EQUATIONS
C
C**
C     D      WRITE(*,*) '  NETWK: CALL SOLVE'
C**
      CALL SOLVE(CMN,RHNT,SCRATC,NTEQ,NDIMN,IPNT,LD2)
C**
C     D      WRITE(*,*) '  NETWK: RTRN SOLVE'
C**
C     ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TO
C     STRUCTURE AND SOLVE FOR INDUCED CURRENT
C
      DO 45 I=1,NTEQ
      IROW1=NTEQA(I)
      EINC(IROW1)=EINC(IROW1)-RHNT(I)
45      CONTINUE
C**
C     D      WRITE(*,*) '  NETWK: CALL SOLGF, CABC AFTER 45'
C**
      CALL SOLGF(CM,CMB,CMC,CMD,EINC,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
     1 NEQZ2,IP,LD2,LD3,IRESRV)
      CALL CABC(EINC,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
     1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
      IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,61)
      IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,60)
      DO 46 I=1,NTEQ
      IROW1=NTEQA(I)
      VLT=RHNT(I)*T1X(IROW1)*WLAM
      CUX=EINC(IROW1)*WLAM
      YMIT=CUX/VLT
      ZPED=VLT/CUX
      IROW2=ITAG(IROW1)
      PWR=.5*DREAL(VLT*DCONJG(CUX))
      PNLS=PNLS-PWR
46    IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,62) IROW2,IROW1,
     1 VLT,CUX,ZPED,YMIT,PWR
      IF (NTSC.EQ.0) GO TO 49
      DO 47 I=1,NTSC
      IROW1=NTSCA(I)
      VLT=VSRC(I)
      CUX=EINC(IROW1)*WLAM
      YMIT=CUX/VLT
      ZPED=VLT/CUX
      IROW2=ITAG(IROW1)
      PWR=.5*DREAL(VLT*DCONJG(CUX))
      PNLS=PNLS-PWR
47    IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,62)  IROW2,IROW1,
     1 VLT,CUX,ZPED,YMIT,PWR
      GO TO 49
C
C     SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT
C
48      CONTINUE
C**
C     D      WRITE(*,*) '  NETWK: CALL SOLGF, CABC AFTER 48'
C**
      CALL SOLGF(CM,CMB,CMC,CMD,EINC,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
     1 NEQZ2,IP,LD2,LD3,IRESRV)
      CALL CABC(EINC,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
     1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
C**
      NTSC=0
49    IF (NSANT+NVQD.EQ.0) RETURN
      IF(NAMPRT.EQ.0) WRITE(IW,63)
      IF(NAMPRT.EQ.0) WRITE(IW,60)
      IF (NSANT.EQ.0) GO TO 56
      DO 55 I=1,NSANT
      ISC1=ISANT(I)
      VLT=VSANT(I)
      IF (NTSC.EQ.0) GO TO 51
      DO 50 J=1,NTSC
      IF (NTSCA(J).EQ.ISC1) GO TO 52
50    CONTINUE
51    CUX=EINC(ISC1)*WLAM
      IROW1=0
      GO TO 54
52    IROW1=NDIMNP-J
      CUX=RHNX(IROW1)
      DO 53 J=1,NTEQ
53    CUX=CUX-CMN(J,IROW1)*RHNT(J)
      CUX=(EINC(ISC1)+CUX)*WLAM
54    YMIT=CUX/VLT
      ZPED=VLT/CUX
      PWR=.5*DREAL(VLT*DCONJG(CUX))
      PIN=PIN+PWR
      IF (IROW1.NE.0) PNLS=PNLS+PWR
      IROW2=ITAG(ISC1)
55      IF(NAMPRT.EQ.0) WRITE(IW,62)  IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR
56    IF (NVQD.EQ.0) RETURN
      DO 57 I=1,NVQD
      ISC1=IVQD(I)
      VLT=VQD(I)
      CUX=DCMPLX(AIR(ISC1),AII(ISC1))
      YMIT=DCMPLX(BIR(ISC1),BII(ISC1))
      ZPED=CMPLX(CIR(ISC1),CII(ISC1))
      PWR=T1X(ISC1)*TP*.5
      CUX=(CUX-YMIT*DSIN(PWR)+ZPED*DCOS(PWR))*WLAM
      YMIT=CUX/VLT
      ZPED=VLT/CUX
      PWR=.5*DREAL(VLT*DCONJG(CUX))
      PIN=PIN+PWR
      IROW2=ITAG(ISC1)
57      IF(NAMPRT.EQ.0) WRITE(IW,64)  IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR
C**
C     D      WRITE(*,*) '  NETWK: RETURN AT END'
C**
      RETURN
C
58    FORMAT (///,3X,47HMAXIMUM RELATIVE ASYMMETRY OF THE DRIVING POINT,
     121H ADMITTANCE MATRIX IS,1P,E10.3,13H FOR SEGMENTS,I5,
     24H AND,I5,/,3X,25HRMS RELATIVE ASYMMETRY IS,E10.3)
59    FORMAT (1X,'ERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL')
60    FORMAT (/,3X,3HTAG,3X,4HSEG.,4X,15HVOLTAGE (VOLTS),9X,14HCURRENT (
     1AMPS),9X,16HIMPEDANCE (OHMS),8X,17HADMITTANCE (MHOS),6X,5HPOWER,/,
     23X,3HNO.,3X,3HNO.,4X,4HREAL,8X,5HIMAG.,3(7X,4HREAL,8X,5HIMAG.),5X,
     37H(WATTS))
61    FORMAT (///,27X,66H- - - STRUCTURE EXCITATION DATA AT NETWORK CONN
     1ECTION POINTS - - -)
62    FORMAT (2(1X,I5),1P,9E12.5)
63    FORMAT (///,42X,36H- - - ANTENNA INPUT PARAMETERS - - -)
64    FORMAT (1X,I5,2H *,I4,1P,9E12.5)
      END
C
C
C
      SUBROUTINE CABC(CURX,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
     1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
C
C     CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), AND
C     COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THE
C     CURRENT VECTOR CUR.
C
      REAL*8 TP,CCJX,AX,BX,CX,AIR,AII,BIR,BII,CIR,CII,AR,AI,SH
CLARGE CURX
      COMPLEX CURX
      COMPLEX*16 CCJ
      COMPLEX*16 VQD,VSANT,VQDS
      COMPLEX*16 CURD,CS1,CS2
      INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
      COMMON/SEGJ/AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
     1 IPCON(10),NPCON
      COMMON/VSORC/VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
     1 IQDS(30),NVQD,NSANT,NQDS
      DIMENSION CURX(LD3),CCJX(2),ICON1(LD),ICON2(LD)
      DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
      DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),BI(LD)
      EQUIVALENCE (CCJ,CCJX)
      DATA TP/6.283185308D0/,CCJX/0.,-0.01666666667D0/
C**
C     E      WRITE(*,*) '   CABC: START'
C**
      IF (N.EQ.0) GO TO 6
      DO 1 I=1,N
      AIR(I)=0.
      AII(I)=0.
      BIR(I)=0.
      BII(I)=0.
      CIR(I)=0.
      CII(I)=0.
1      CONTINUE
C**
      DO 2 I=1,N
C      AR=DREAL(CURX(I))
C      AI=DIMAG(CURX(I))
      AR=REAL(CURX(I))
      AI=IMAG(CURX(I))
      IDM1=1
      CALL TBF(T1X,BI,ICON1,ICON2,IDM1,I,LD)
      DO 2 JX=1,JSNO
      J=JCO(JX)
      AIR(J)=AIR(J)+AX(JX)*AR
      AII(J)=AII(J)+AX(JX)*AI
      BIR(J)=BIR(J)+BX(JX)*AR
      BII(J)=BII(J)+BX(JX)*AI
      CIR(J)=CIR(J)+CX(JX)*AR
      CII(J)=CII(J)+CX(JX)*AI
2      CONTINUE
      IF (NQDS.EQ.0) GO TO 4
C**
      IDM1=0
      DO 3 IS=1,NQDS
      I=IQDS(IS)
      JXX=ICON1(I)
      ICON1(I)=0
      CALL TBF(T1X,BI,ICON1,ICON2,IDM1,I,LD)
      ICON1(I)=JXX
      SH=T1X(I)*.5
      CURD=CCJ*VQDS(IS)/((DLOG(2.*SH/BI(I))-1.)*(BX(JSNO)*DCOS(TP*SH)
     1 +CX(JSNO)*DSIN(TP*SH))*WLAM)
      AR=DREAL(CURD)
      AI=DIMAG(CURD)
      DO 3 JX=1,JSNO
      J=JCO(JX)
      AIR(J)=AIR(J)+AX(JX)*AR
      AII(J)=AII(J)+AX(JX)*AI
      BIR(J)=BIR(J)+BX(JX)*AR
      BII(J)=BII(J)+BX(JX)*AI
      CIR(J)=CIR(J)+CX(JX)*AR
      CII(J)=CII(J)+CX(JX)*AI
3      CONTINUE
4      CONTINUE
      DO 5 I=1,N
      CURX(I)=CMPLX(AIR(I)+CIR(I),AII(I)+CII(I))
5      CONTINUE
6      CONTINUE
      IF (M.EQ.0) RETURN
C     CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS
      K=LD-M
      JCO1=N+2*M+1
      JCO2=JCO1+M
      DO 7 I=1,M
      K=K+1
      JCO1=JCO1-2
      JCO2=JCO2-3
      CS1=CURX(JCO1)
      CS2=CURX(JCO1+1)
      CURX(JCO2)=CS1*T1X(K)+CS2*T2X(K)
      CURX(JCO2+1)=CS1*T1Y(K)+CS2*T2Y(K)
7     CURX(JCO2+2)=CS1*T1Z(K)+CS2*T2Z(K)
      RETURN
      END
C
C
C
      SUBROUTINE SOLGF(A,B,C,D,XY,Y,NP,N1,N,MP,M1,M,N1C,N2C,N2CZ,
     1 IP,LD2,LD3,IRESRV)
C     SOLVE FOR CURRENT IN N.G.F. PROCEDURE
      INTEGER*4 NP,N1,N,MP,M1,M,N1C,N2C
      REAL*8 AX,BX,CX
CLARGE: A,B,C,D,XY
      COMPLEX A,B,C,D,XY
      COMPLEX*16 Y,SUM
      DIMENSION B(N1C,1),C(N1C,1),D(N2CZ,1),XY(LD3),
     1 IP(LD2),Y(LD2)
      COMMON/SEGJ/AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
     1 IPCON(10),NPCON
      INTEGER*4 IMAT,NPBLK,NLAST,NLSYM,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
      COMMON/MATPAR/ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
     1 ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
      IFL=14
      IF (ICASX.GT.0) IFL=13
C**
C     D      WRITE(*,*) '   SOLGF: START IFL=',IFL,' ICASX=',ICASX,' N2C=',N2C
C**
      IF (N2C.GT.0) GO TO 1
C     NORMAL SOLUTION.  NOT N.G.F.
      CALL SOLVES(A,XY,Y,N1C,NP,N,MP,M,IP,1,13,IFL,LD2,IRESRV)
      GOTO 22
1     IF (N1.EQ.N.OR.M1.EQ.0) GO TO 5
C     REORDER EXCITATION ARRAY
      N2=N1+1
      JJ=N+1
      NPM=N+2*M1
      DO 2 I=N2,NPM
2     Y(I)=XY(I)
      J=N1
      DO 3 I=JJ,NPM
      J=J+1
3     XY(J)=Y(I)
      DO 4 I=N2,N
      J=J+1
4     XY(J)=Y(I)
5     NEQS=NSCON+2*NPCON
      IF (NEQS.EQ.0) GO TO 7
      NEQ=N1C+N2C
      NEQS=NEQ-NEQS+1
C     COMPUTE INV(A)E1
      DO 6 I=NEQS,NEQ
6     XY(I)=(0.,0.)
7     CALL SOLVES(A,XY,Y,N1C,NP,N1,MP,M1,IP,1,13,IFL,LD2,IRESRV)
      NI=0
      NPB=NPBL
C     COMPUTE E2-C(INV(A)E1)
      DO 10 JJ=1,NBBL
      IF (JJ.EQ.NBBL) NPB=NLBL
      IF (ICASX.GT.1) READ (15) ((C(I,J),I=1,N1C),J=1,NPB)
      II=N1C+NI
      DO 9 I=1,NPB
      SUM=(0.,0.)
      DO 8 J=1,N1C
8     SUM=SUM+C(J,I)*XY(J)
      J=II+I
9     XY(J)=XY(J)-SUM
10    NI=NI+NPBL
C**
C     D      WRITE(*,*) '   SOLGF: OPEN 15'
C**
      OPEN (15,FORM='UNFORMATTED')
      JJ=N1C+1
C     COMPUTE INV(D)(E2-C(INV(A)E1)) = I2
      IF (ICASX.GT.1) GO TO 11
      CALL SOLVE(D,XY(JJ),Y,N2C,N2C,IP(JJ),LD2)
      GO TO 13
11    IF (ICASX.EQ.4) GO TO 12
      NI=N2C*N2C
      READ (11) (B(J,1),J=1,NI)
      REWIND 11
      CALL SOLVE(B,XY(JJ),Y,N2C,N2C,IP(JJ),LD2)
      GO TO 13
12    NBLSYS=NBLSYM
      NPSYS=NPSYM
      NLSYS=NLSYM
      ICASS=ICASE
      NBLSYM=NBBL
      NPSYM=NPBL
      NLSYM=NLBL
      ICASE=3
      REWIND 11
C**
C     D      WRITE(*,*) '   SOLGF: OPEN 16'
C**
      OPEN (16,FORM='UNFORMATTED')
C**
C     D      WRITE(*,*) '   SOLGF: CALL LTSOLV'
C**
      CALL LTSOLV (B,XY(JJ),Y,IP(JJ),N2C,N2C,1,11,16,LD2)
C**
C     D      WRITE(*,*) '   SOLGF: RTRN LTSOLV'
C**
      REWIND 11
      REWIND 16
      NBLSYM=NBLSYS
      NPSYM=NPSYS
      NLSYM=NLSYS
      ICASE=ICASS
13    NI=0
      NPB=NPBL
C     COMPUTE INV(A)E1-(INV(A)B)I2 = I1
      DO 16 JJ=1,NBBL
      IF (JJ.EQ.NBBL) NPB=NLBL
      IF (ICASX.GT.1) READ (14) ((B(I,J),I=1,N1C),J=1,NPB)
      II=N1C+NI
      DO 15 I=1,N1C
      SUM=(0.,0.)
      DO 14 J=1,NPB
      JP=II+J
14    SUM=SUM+B(I,J)*XY(JP)
15    XY(I)=XY(I)-SUM
16    NI=NI+NPBL
C**
C     D      WRITE(*,*) '   SOLGF: OPEN 14'
C**
      OPEN (14,FORM='UNFORMATTED')
      IF (N1.EQ.N.OR.M1.EQ.0) GO TO 20
C     REORDER CURRENT ARRAY
      DO 17 I=N2,NPM
17    Y(I)=XY(I)
      JJ=N1C+1
      J=N1
      DO 18 I=JJ,NPM
      J=J+1
18    XY(J)=Y(I)
      DO 19 I=N2,N1C
      J=J+1
19    XY(J)=Y(I)
20    IF (NSCON.EQ.0) GO TO 22
      J=NEQS-1
      DO 21 I=1,NSCON
      J=J+1
      JJ=ISCON(I)
21    XY(JJ)=XY(J)
22      CONTINUE
C**
C     D      WRITE(*,*) '   SOLGF: RETURN'
C**
      RETURN
      END
